unit txtGraph;

interface

uses
	jfunc;

const
	videoCard_mda=0;
	videoCard_cga=1;
	videoCard_pcJr=2;
	videoCard_tandy1000=3;
	videoCard_tandySLTL=4;
	videoCard_ega=5;
	videoCard_vga=6;
	videoCardName:packed array[0..videoCard_vga] of string[11]=(
		'MDA','CGA','PCJr','Tandy 1000','Tandy TL/SL','EGA','VGA'
	);

type
	pTileData=^byte;

	pTileSet=^tileSet;
	tileSet=object
		size:word;
		name:dosName;
		dataStart,
		dataEnd:pTileData;
		constructor init(dataFile:dosName);
		destructor term;
	end;

	pKernSet=^kernSet;
	kernSet=packed array[0..255] of byte;

	writeTileProc=procedure(x,y:integer; tileSet:pointer; tile:byte);
	backgroundProc=procedure(x,y:integer; data:pTileData);
	bufferShowProc=procedure(x,y:integer);

	pfontSet=^fontSet;
	fontSet=object(tileSet)
		glyphStart,
		glyphCount,
		glyphSize:word;
		writeTile:writeTileProc;
		kernData:pKernSet;
		constructor init(dataFile:dosName);
		function textLength(st:st40):word;
		procedure outText(x,y:word; st:st40);
		procedure outTextRight(x,y:word; st:st40);
		procedure outTextCentered(x,y:word; st:st40);
		destructor term;
	end;

	pNumberSet=^numberSet;
	numberSet=object(tileSet)
		procedure outDecNonPadded(x,y:word; n:longint; colorSet:byte);
		procedure outDecimal(x,y:word; n:longint; colorSet:byte);
		procedure outHex(x,y:word; n:longint; colorSet:byte);
	end;

	pSprite=^Sprite;
	sprite=object
		{ these values the user can change directly }
		currentX,currentY,currentTile,
		bufferX,bufferY:integer;

		{ from here out this should be left to the code to manage }
		oldX,oldY,sTileSize:integer;
		sTiles:pTileSet;
		storeSize:word;
		store:pTileData;

		{ function handlers, prevents needing a 'case' statement inside the loop }
		writeTile,
		bufferWriteTile:writeTileProc;
		bufferShow:bufferShowProc;
	  getBackground,
	  restoreBackground:backgroundProc;

	  { pointers for list control }
		prev,next:pSprite;

		constructor init(parent:pSprite; x,y,tile,tileSize:integer; tiles:pTileSet);
		procedure hide;
		procedure show;
		procedure bufferHide;
		procedure bufferRender;
		destructor term;
	end;

	pUpdateBlock=^updateBlock;
	updateBlock=object
		x,y:integer;
		update:boolean;
		next:pUpdateBlock;
		constructor init(ix,iy:integer);
	end;

	updateBlockList=object
		first,last:pUpdateBlock;
		constructor init;
		procedure add(ix,iy:integer);
		destructor term;
	end;

var
	updateList:updateBlockList;
	videoCard:word;

procedure tg_init;
procedure tg_term;

procedure tg_clear(color:byte);

procedure tg_putPixel(x,y:word; color:byte);
procedure tgClip_putPixel(x,y:integer; color:byte);

function tg_getPixel(x,y:word):byte;
function tgClip_getPixel(x,y:integer):byte;

procedure tg_bar(sx,sy,ex,ey:integer; color:byte);
procedure tgClip_bar(sx,sy,ex,ey:integer; color:byte);

procedure tg_tile3(x,y:integer; tileSet:pointer; tile:byte);
procedure tg_tile5(x,y:integer; tileSet:pointer; tile:byte);

procedure tg_getBackground3(x,y:integer; data:pTileData);
procedure tg_getBackground5(x,y:integer; data:pTileData);
procedure tg_getBackground7(x,y:integer; data:pTileData);

procedure tg_restoreBackground3(x,y:integer; data:pTileData);
procedure tg_restoreBackground5(x,y:integer; data:pTileData);
procedure tg_restoreBackground7(x,y:integer; data:pTileData);

procedure tg_waitRetrace;

function buffer_addSprite(x,y,tile,tileSize:integer; tiles:pTileSet):pSprite;

procedure buffer_sourceClear(color:byte);
procedure buffer_copySource2Render;
procedure buffer_copyRender2Screen;
procedure buffer_restore(x,y:integer); { source -> render, 8x8 byte-bound }
procedure buffer_show4x3(x,y:integer);    { render -> display, 8x8 byte-bound }
procedure buffer_show8x6(x,y:integer);    { render -> display, 8x8 byte-bound }
procedure buffer_sourceTile3(x,y:integer; tileSet:pointer; tile:byte);
procedure buffer_sourceTile5(x,y:integer; tileSet:pointer; tile:byte);
procedure buffer_renderTile3(x,y:integer; tileSet:pointer; tile:byte);
procedure buffer_renderTile5(x,y:integer; tileSet:pointer; tile:byte);
procedure buffer_nullTile4x3(x,y:integer); { source buffer }
procedure buffer_showSprites;
procedure buffer_hideSprites;
procedure buffer_updateSprites;

implementation

type

	pPackedBuffer=^tPackedBuffer;
	tPackedBuffer=array[0..7999] of byte;

	tgWindow=record
		sx,sy,ex,ey:integer;
	end;

	regData=packed record
		register:word;
		data:string[26];
	end;

{
	Why store regData.data in a string? Because it gives
	us a size byte BEFORE the content in the data stream,
	and it's the only dynamic size data type you can use
	in a constant.

	Too bad we can't just read this crap from the EGA/VGA
	data tables, but for some reason DosBox doesn't provide
	those... and it would be nice to have this work on real
	hardware AND dosBox.
}

const
	pageSize=$3E80;
	pageSizeWords=pageSize shr 1;

	CGA_Regs:regData=(
		register:$3D4;
		data:#04+#$7F + #06+#$64 + #07+#$70 + #09+#$01
	);

	EGA_Sequencer:regData=(
		register:$3C4;
		data:#03+#01+#03+#00+#03
	);
	EGA_CRTC:regData=(
		register:$3D4;
		data:
			#$70+#$4F+#$5C+#$2F + #$5F+#$07+#$04+#$11 +
			#$00+#$01+#$06+#$07 + #$00+#$00+#$00+#$00 +
			#$E1+#$24+#$C7+#$28 + #$08+#$E0+#$F0+#$A3 +
			#$FF+#$00
	);

	VGA_Sequencer:regData=(
		register:$3C4;
		data:#03+#01+#03+#00+#02
	);
	VGA_CRTC:regData=(
		register:$3D4;
		data:
			#$5F+#$4F+#$50+#$82 + #$55+#$81+#$BF+#$1F +
			#$00+#$43+#$06+#$07 + #$00+#$00+#$00+#$59 +
			#$9C+#$8E+#$8F+#$28 + #$1F+#$96+#$B9+#$A3 +
			#$FF
	);

	screenBuffer:pPackedBuffer=ptr($B800,$0000);
	packedBufferSize=sizeof(tPackedBuffer);

var
	sourceBuffer,renderBuffer:pPackedBuffer;
	firstSprite,lastSprite:pSprite;
	textSegment:word;
	oldMode:byte;
	oldTgExitProc:pointer;

	textGraphOn:boolean;
	clippingWindow:tgWindow;

	tg_erase:boolean;
	tg_sx,tg_sy,tg_ex,tg_ey:integer;

constructor updateBlock.init(ix,iy:integer);
begin
	x:=ix;
	y:=iy;
	update:=false;
	next:=nil;
end;

constructor updateBlockList.init;
begin
	first:=nil;
	last:=nil;
end;

procedure updateBlockList.add(ix,iy:integer);
begin
	if (first=nil) then begin
		new(first,init(ix,iy));
		last:=first;
	end else begin
		new(last^.next,init(ix,iy));
		last:=last^.next;
	end;
end;

destructor updateBlockList.term;
begin
	while not(first=nil) do begin
		last:=first^.next;
		dispose(first);
		first:=last;
	end;
end;

constructor sprite.init(parent:pSprite; x,y,tile,tileSize:integer; tiles:pTileSet);
begin
	currentX:=x;
	oldX:=x;
	currentY:=y;
	oldY:=y;
	currentTile:=tile;
	sTiles:=tiles;
	sTileSize:=tileSize;
	case sTileSize of
		3:begin
			storeSize:=12;
			writeTile:=tg_tile3;
			bufferWriteTile:=buffer_renderTile3;
			bufferShow:=buffer_show4x3;
		  getBackground:=tg_getBackground3;
		  restoreBackground:=tg_restoreBackground3;
		end;
		5:begin
			storeSize:=30;
			writeTile:=tg_tile5;
			bufferWriteTile:=buffer_renderTile5;
			bufferShow:=buffer_show8x6;
		  getBackground:=tg_getBackground5;
		  restoreBackground:=tg_restoreBackground5;
		end;
	end;
	getmem(store,storeSize);
	prev:=parent;
	next:=nil;
end;

procedure sprite.show;
begin
	getBackground(currentX,currentY,store);
	writeTile(currentX,currentY,sTiles^.dataStart,currentTile);
	oldX:=currentX;
	oldY:=currentY;
end;

procedure sprite.hide;
begin
	restoreBackground(oldX,oldY,store);
end;

procedure sprite.bufferHide;
begin
	buffer_restore(oldX,oldY);
end;

procedure sprite.bufferRender;
begin
	bufferWriteTile(currentX,currentY,sTiles^.dataStart,currentTile);
	oldX:=currentX;
	oldY:=currentY;
end;

destructor sprite.term;
begin
	freemem(store,storeSize);
end;

function buffer_addSprite(x,y,tile,tileSize:integer; tiles:pTileSet):pSprite;
begin
	if firstSprite=nil then begin
		new(firstSprite,init(nil,x,y,tile,tileSize,tiles));
		lastSprite:=firstSprite;
	end else begin
		new(lastSprite^.next,init(lastSprite,x,y,tile,tileSize,tiles));
		lastSprite:=lastSprite^.next;
	end;
	buffer_addSprite:=lastSprite;
end;

procedure discardSprites;
begin
	while not(lastSprite=nil) do begin
		firstSprite:=lastSprite^.prev;
		dispose(lastSprite,term);
		lastSprite:=firstSprite;
	end;
end;

constructor tileSet.init(dataFile:dosName);
var
	f:file;
begin
	name:=datafile;
	assign(f,name+'.DAT');
	reset(f,1);
	size:=filesize(f);
	getmem(dataStart,size);
	dataEnd:=dataStart;
	inc(dataEnd,size);
	blockread(f,dataStart^,size);
	close(f);
end;

destructor tileSet.term;
begin
	freemem(dataStart,size);
end;

constructor fontSet.init(dataFile:dosName);
var
	f:file;
	p,e:pTileData;
begin
	tileSet.init(dataFile);
	assign(f,name+'.KRN');
	reset(f,1);
	blockread(f,glyphStart,2);
	blockread(f,glyphCount,2);
	blockread(f,glyphSize,2);
	getmem(kernData,glyphCount);
	blockread(f,kernData^,glyphCount);
	close(f);
	case glyphSize of
		3:writeTile:=tg_tile3;
		5:writeTile:=tg_tile5;
	end;
end;

function fontSet.textLength(st:st40):word;
var
	t,sx:word;
	b:byte;
begin
	sx:=0;
	t:=0;
	while (t<length(st)) do begin
		inc(t);
		b:=ord(st[t])-glyphStart;
		{ remap high values into end of table }
		while (b>glyphCount) do b:=b-$20;
		sx:=sx+kernData^[b];
	end;
	textLength:=sx;
end;

procedure fontSet.outText(x,y:word; st:st40);
var
	sx,t:word;
	b:byte;
begin
	sx:=x;
	t:=0;
	while (t<length(st)) do begin
		inc(t);
		b:=ord(st[t])-GlyphStart;
		{ remap high values into end of table }
		while (b>=glyphCount) do b:=b-$20;
		writeTile(sx,y,dataStart,b);
		sx:=sx+kernData^[b];
	end;
end;

procedure fontSet.outTextCentered(x,y:word; st:st40);
var
	sx:word;
begin
	sx:=x-textLength(st) div 2;
	outText(sx,y,st);
end;

procedure fontSet.outTextRight(x,y:word; st:st40);
var
	sx:word;
begin
	sx:=x-textLength(st);
	outText(sx,y,st);
end;

destructor fontSet.term;
begin
	tileSet.term;
	freemem(kernData,glyphCount);
end;

procedure numberSet.outDecNonPadded(x,y:word; n:longint; colorSet:byte);
var
	sx:word;
	d:longint;
	b:byte;
	started:boolean;
begin
	d:=10000000;
	sx:=x;
	started:=false;
	while (d>0) do begin
		b:=((n div d) mod 10);
		d:=d div 10;
		if (b>0) or started then begin
			tg_tile5(sx,y,dataStart,b+colorSet*16);
			inc(sx,4);
			started:=true;
		end;
	end;
end;


procedure numberSet.outDecimal(x,y:word; n:longint; colorSet:byte);
var
	sx:word;
	d:longint;
	b:byte;
begin
	d:=10000000;
	sx:=x;
	while (d>0) do begin
		b:=((n div d) mod 10)+colorSet*16;
		d:=d div 10;
		tg_tile5(sx,y,dataStart,b);
		inc(sx,4);
	end;
end;

procedure numberSet.outHex(x,y:word; n:longint; colorSet:byte);
var
	sx:word;
	d:longint;
	b:byte;
begin
	d:=$10000000;
	sx:=x;
	while (d>0) do begin
		b:=((n div d) and $0F)+colorSet*16;
		d:=d div $10;
		tg_tile5(sx,y,dataStart,b);
		inc(sx,4);
	end;
end;

procedure tg_waitRetrace; assembler;
asm
	mov  dx,$3DA
	mov  ah,$08
@loop:
	in   al,dx
	and  al,ah
	jz   @loop
end;

procedure outCGAPort(data:pointer); assembler;
asm
	les  di,data
	mov  dx,es:[di]
	add  di,2
	xor  ch,ch
	mov  cl,es:[di]
	shr  cl,1
	inc  di
@loopRegData:
	mov  ax,es:[di]
	out  dx,ax
	add  di,2
	loop @loopRegData
end;

procedure outEGAVGAPort(data:pointer); assembler;
asm
	les  di,data
	mov  dx,es:[di]
	add  di,2
	xor  cx,cx
	mov  cl,es:[di]
	inc  di
	xor  al,al
@loopEGAVGA:
	mov  ah,es:[di]
	out  dx,ax
	inc  di
	inc  al
	loop @loopEGAVGA
end;

procedure disableVideoOutputAndInterrupts; assembler;
asm
	{ video off first }
	mov  dx,$03D8
	mov  al,1
	out  dx,al
	{ disable normal interrupts }
	cli
	{ disable NMI too -- can't have CRTC interuppted! }
	in   al,$70
	and  al,$7F
	out  $70,al
end;

procedure enableVideoOutputAndInterrupts; assembler;
asm
	{ enable NMI }
	in   al,$70
	or   al,$80
	out  $70,al
	{ enable normal interrupts }
	sti
	{ video on }
	mov  dx,$03D8
	mov  al,9
	out  dx,al
end;

procedure load8x8; assembler;
asm
	mov  ax,$1102 { load 8x8 font }
	xor  bl,bl
	int  $10
end;

procedure blinkOff; assembler;
asm
	mov  ax,$1003 { disable Blink }
	xor  bl,bl
	int  $10
end;

procedure brownFix; assembler;
asm
	mov  ax,$1000 { make EGA/VGA color 6 brown }
	mov  bx,$1406
{	int  $10 disabled, giving RED on some units }
end;

procedure charHeight(height:byte); assembler;
asm
	mov  ah,height { shorten line-heights }
	mov  al,$09
	mov  dx,$3D4
	out  dx,ax
end;

procedure egaVgaUnsafe;
begin
	load8x8;
	blinkOff;
	brownFix;
end;

procedure egaVGASafe(lineHeight:byte);
begin
	charHeight(lineHeight);
	blinkOff;
	brownFix;
end;

{
	Detecting which video card is present is kinda tricky...
	but thankfully they did something smart with int $10.
	Calls to unknown subfunctions just RET leaving registers
	intact, so if you call a VGA function that you know changes
	a register, and the register doesn't change, it's not a VGA.
	Call a EGA function ditto, ditto... finally check if we're in
	a monochrome display mode, that's MDA.

	Unfortunately there's no known reliable check for a CGA since
	newer cards pretend to be one -- but if we eliminate
	'everything else' from the list, it must be CGA.
}

function detectCard:byte; assembler;
asm
	mov  ax,$1200
	mov  bl,$32       { VGA only enable video }
	int  $10
	cmp  al,$12       { VGA returns $12, all others leave it unmodified! }
	jne  @notVGA      { not a vga, test for EGA }
	mov  al,videoCard_vga
	ret
@notVGA:           { We eliminated VGA, so an EGA/VGA true must be EGA }
	mov  ah,$12
	mov  bl,$10       { EGA/VGA get configuration info }
	int  $10
	and  bl,$03       { EGA/VGA returns a 0..3 value here }
	jz   @notEGA      { not a VGA, test for MDA }
	mov  al,videoCard_ega
	ret
@notEGA:            { MDA all we need to detect is video mode 7 }
	mov  ah,$0F       { get Video mode }
	int  $10
	cmp  al,$07
	jne  @notMDA
	mov  al,videoCard_mda
	ret
@notMDA:            { not MDA, check for Jr. }
	mov  ax,$FFFF
	mov  es,ax
	mov  di,$000E     { second to last byte PCjr/Tandy BIOS info area }
	mov  al,$FD       { ends up $0F only on the Jr. }
	cmp  es:[di],al
	jne  @notJr
	mov  al,videoCard_pcJr
	ret
@notJr:             { not junior, test for tandy }
	mov  al,$FF       { all tandy's return $FF here }
	cmp  es:[di],al
	jne  @notTandy
	mov  ax,$FC00
	mov  es,ax
	xor  di,di
	mov  al,$21
	cmp  es:[di],al
	jne  @notTandy
	mov  ah,$C0       { test for SL/TL }
	int  $15          { Get System Environment }
	jnc  @tandySLTL     { early Tandy's leave the carry bit set, TL/SL does not }
	mov  al,videoCard_tandy1000
	ret
@tandySLTL:
	mov  al,videoCard_tandySLTL
	ret
@notTandy:
	mov  al,videoCard_cga { all other cards eliminated, must be CGA }
end;

function getVideoMode:byte; assembler;
asm
	mov  ax,$0F00;
	int  $10;
end;

procedure setVideoMode(mode:byte); assembler;
asm
	xor ah,ah
	mov al,mode
	int $10;
end;

procedure tg_putPixel(x,y:word; color:byte); assembler;
asm
	mov  ax,y
	mov  di,ax
	mov  cl,7
	shl  di,cl
	mov  cl,5
	shl  ax,cl
	add  di,ax

	mov  dx,x
	add  di,dx
	or   di,1

	mov  al,color
	mov  bx,textSegment
	mov  es,bx
	mov  bl,es:[di]

	and  dx,1
	jnz  @xOdd

	and  bl,$F0
	jmp  @xDone

@xOdd:
	and  bl,$0F
	mov  cl,4
	shl  al,cl

@xDone:
	or   al,bl
	mov  es:[di],al
end;

function tg_getPixel(x,y:word):byte; assembler;
asm
	mov  ax,y
	mov  di,ax
	mov  cl,7
	shl  di,cl
	mov  cl,5
	shl  ax,cl
	add  di,ax

	mov  dx,x
	add  di,dx
	or   di,1

	mov  bx,textSegment
	mov  es,bx
	mov  al,es:[di]

	and  dx,$01
	jz   @xEven

	mov  cl,4
	shr  al,cl

@xEven:
	and  al,$0F
end;

procedure hLine(x,y,disX:integer; color:byte); assembler;
asm
	mov  ax,y
	mov  di,ax
	mov  cl,7
	shl  di,cl
	mov  cl,5
	shl  ax,cl
	add  di,ax

	mov  bx,x
	add  di,bx
	or   di,1

	mov  ax,textSegment
	mov  es,ax

	mov  dx,disX

	mov  bh,color
	mov  al,bh

	mov  cl,4
	shl  al,cl

	and  bl,1
	jz   @hLongRun

	mov  bl,es:[di]
	and  bl,$0F
	or   bl,al
	mov  es:[di],bl
	add  di,2
	dec  dx

@hLongRun:
	cmp  dx,2
	jl   @hFinalPixel
	mov  ah,al
	or   ah,bh
	mov  al,$DD
	mov  cx,dx
	shr  cx,1
	dec  di
	rep  stosw
	inc  di

@hFinalPixel:
	test dx,1
	jz   @hLineDone
	mov  al,es:[di]
	and  al,$F0
	or   al,bh
	mov  es:[di],al
@hLineDone:
end;

procedure vLine(x,y,disY:word; color:byte); assembler;
asm
	mov  ax,y
	mov  bx,160
	mul  bx
	mov  di,ax

	mov  dx,x
	add  di,dx
	or   di,1

	mov  ax,textSegment
	mov  es,ax

	mov  bl,color
	mov  bh,$F0 {
		It's faster to set BH and then change it on condition
		than it is to add all sorts of test and jump logic to
		only set $F0 as needed
	}

	and  dx,1
	jz   @vSetDistance

	mov  cl,4
	shl  bl,cl
	mov  bh,$0F

@vSetDistance:
	mov  cx,disY

@vLineLoop:
	mov  al,es:[di]
	and  al,bh
	or   al,bl
	mov  es:[di],al
	add  di,$A0
	loop @vLineLoop
end;


function inWindow(x,y:integer):boolean;
begin
	inWindow:=(
		(x>=clippingWindow.sx) and
		(x<=clippingWindow.ex) and
		(y>=clippingWindow.sy) and
		(y<=clippingWindow.ey)
	);
end;

procedure tgClip_putPixel(x,y:integer; color:byte);
begin
	if inWindow(x,y) then tg_putPixel(x,y,color);
end;

function tgClip_getPixel(x,y:integer):byte;
begin
	if inWindow(x,y) then begin
		tgClip_getPixel:=tg_getPixel(x,y);
	end else tgClip_getPixel:=0;
end;

procedure tg_bar(sx,sy,ex,ey:integer; color:byte);
var
	y,distance:integer;
begin
	distance:=(ex-sx);
	if (distance=0) then begin
		vLine(sx,sy,(ey-sy)+1,color);
	end else begin
		y:=sy;
		inc(distance);
		while (y<=ey) do begin
			hLine(sx,y,distance,color);
			inc(y);
		end;
	end;
end;

procedure tgClip_bar(sx,sy,ex,ey:integer; color:byte);
var
	csx,cex,csy,cey:integer;
begin
	if (sx<ex) then begin
		csx:=sx;
		cex:=ex;
	end else begin
		csx:=ex;
		cex:=sx;
	end;
	if (csx<=clippingWindow.ex) and (cex>=clippingWindow.sx) then begin
		if (sy<ey) then begin
			csy:=sy;
			cey:=ey;
		end else begin
			csy:=ey;
			cey:=sy;
		end;
		if (csy<=clippingWindow.ey) and (cey>=clippingWindow.sy) then begin
			if (csx<clippingWindow.sx) then csx:=clippingWindow.sx;
			if (cex>clippingWindow.ex) then cex:=clippingWindow.ex;
			if (csy<clippingWindow.sy) then csy:=clippingWindow.sy;
			if (cey>clippingWindow.ey) then cey:=clippingWindow.ey;
			tg_bar(csx,csy,cex,cey,color);
		end;
	end;
end;

procedure tg_tile3(x,y:integer; tileSet:pointer; tile:byte); assembler;
asm
	{ set video address for STOSW }
	mov  ax,$B800
	mov  es,ax
	mov  ax,y
	mov  bx,160
	mul  bx
	mov  cx,x
	mov  di,ax
	add  di,cx
	or   di,1

	{ calculate tile offset }
	xor  ax,ax
	mov  al,tile
	mov  bx,24
	mul  bx
	and  cx,1
	jnz  @oddtile
	add  ax,12
@oddTile:
	mov  dx,ds
	lds  si,tileSet
	add  si,ax

	mov  cx,3

@tileLoop:

	lodsw
	mov  bx,ax
	mov  ax,es:[di]
	and  al,bh
	or   al,bl
	stosw

	lodsw
	mov  bx,ax
	mov  ax,es:[di]
	and  al,bh
	or   al,bl
	stosw

	add  di,156

	loop @tileLoop

	mov ds,dx
end;

procedure tg_tile5(x,y:integer; tileSet:pointer; tile:byte); assembler;
asm
	{ set video address for STOSW }
	mov  ax,$B800
	mov  es,ax
	mov  ax,y
	mov  bx,160
	mul  bx
	mov  cx,x
	mov  di,ax
	add  di,cx
	or   di,1

	{ calculate tile offset }
	xor  ax,ax
	mov  al,tile
	mov  bx,60
	mul  bx
	and  cx,1
	jnz  @oddtile
	add  ax,30
@oddTile:
	mov  dx,ds
	lds  si,tileSet
	add  si,ax

	mov  cx,5

@tileLoop:

	lodsw
	mov  bx,ax
	mov  ax,es:[di]
	and  al,bh
	or   al,bl
	stosw

	lodsw
	mov  bx,ax
	mov  ax,es:[di]
	and  al,bh
	or   al,bl
	stosw

	lodsw
	mov  bx,ax
	mov  ax,es:[di]
	and  al,bh
	or   al,bl
	stosw

	add  di,154

	loop @tileLoop

	mov ds,dx
end;

procedure tg_getBackground3(x,y:integer; data:pTileData); assembler;
asm
	les  di,data
	mov  ax,y
	mov  bx,160
	mul  bx
	mov  si,x
	add  si,ax
	or   si,1
	mov  ax,$B800
	mov  dx,ds
	mov  ds,ax
	mov  cx,3
	mov  bx,156
@getLoop:
	movsw
	movsw
	add  si,bx
	loop @getLoop
	mov  ds,dx
end;

procedure tg_getBackground5(x,y:integer; data:pTileData); assembler;
asm
	les  di,data
	mov  ax,y
	mov  bx,160
	mul  bx
	mov  si,x
	add  si,ax
	or   si,1
	mov  ax,$B800
	mov  dx,ds
	mov  ds,ax
	mov  cx,5
	mov  bx,154
@getLoop:
	movsw
	movsw
	movsw
	add  si,bx
	loop @getLoop
	mov  ds,dx
end;

procedure tg_getBackground7(x,y:integer; data:pTileData); assembler;
asm
	les  di,data
	mov  ax,y
	mov  bx,160
	mul  bx
	mov  si,x
	add  si,ax
	or   si,1
	mov  ax,$B800
	mov  dx,ds
	mov  ds,ax
	mov  cx,5
	mov  bx,152
@getLoop:
	movsw
	movsw
	movsw
	movsw
	add  si,bx
	loop @getLoop
	mov  ds,dx
end;

procedure tg_restoreBackground3(x,y:integer; data:pTileData); assembler;
asm
	mov  ax,y
	mov  bx,160
	mul  bx
	mov  di,x
	add  di,ax
	or   di,1
	mov  ax,$B800
	mov  es,ax
	mov  cx,3
	mov  bx,156
	mov  dx,ds
	lds  si,data
@putLoop:
	movsw
	movsw
	add  di,bx
	loop @putLoop
	mov  ds,dx
end;

procedure tg_restoreBackground5(x,y:integer; data:pTileData); assembler;
asm
	mov  ax,y
	mov  bx,160
	mul  bx
	mov  di,x
	add  di,ax
	or   di,1
	mov  ax,$B800
	mov  es,ax
	mov  cx,5
	mov  bx,154
	mov  dx,ds
	lds  si,data
@putLoop:
	movsw
	movsw
	movsw
	add  di,bx
	loop @putLoop
	mov  ds,dx
end;

procedure tg_restoreBackground7(x,y:integer; data:pTileData); assembler;
asm
	mov  ax,y
	mov  bx,160
	mul  bx
	mov  di,x
	add  di,ax
	or   di,1
	mov  ax,$B800
	mov  es,ax
	mov  cx,7
	mov  bx,152
	mov  dx,ds
	lds  si,data
@putLoop:
	movsw
	movsw
	movsw
	movsw
	add  di,bx
	loop @putLoop
	mov  ds,dx
end;

procedure buffer_sourceClear(color:byte); assembler;
asm
	les  di,sourceBuffer
	mov  al,color
	mov  ah,al
	mov  cl,4
	shl  al,cl
	or   al,ah
	mov  ah,al
	mov  cx,packedBufferSize shr 1
	rep  stosw
end;

procedure buffer_copySource2Render; assembler;
asm
	mov  dx,ds { faster than a push/pop to just use dx }
	mov  cx,packedBufferSize shr 1
	les  di,renderBuffer
	lds  si,sourceBuffer
	rep  movsw
	mov  ds,dx
end;

procedure buffer_copyRender2Screen; assembler;
asm
	mov  cx,packedBufferSize
	mov  ax,$B800
	mov  es,ax
	xor  di,di

	mov  dx,ds { faster than a push/pop to just use dx }
	lds  si,renderBuffer
	mov  ah,$DD
@loop:
	lodsb
	xchg al,ah
	stosw
	xchg al,ah
	loop @loop

	mov  ds,dx
end;

procedure buffer_copySource2Screen; assembler;
asm
	mov  cx,packedBufferSize
	mov  ax,$B800
	mov  es,ax
	xor  di,di

	mov  dx,ds { faster than a push/pop to just use dx }
	lds  si,sourceBuffer
	mov  ah,$DD
@loop:
	lodsb
	xchg al,ah
	stosw
	xchg al,ah
	loop @loop

	mov  ds,dx
end;

{
	restore copies a 8x8 section from sourceBuffer to renderBuffer
	ON THE BYTE BOUNDARY!!!
}
procedure buffer_restore(x,y:integer); assembler;
asm
	mov  ax,y
	dec  ax
	mov  bx,$50
	mul  bx
	mov  bx,x
	dec  bx
	shr  bx,1
  add  bx,ax { bx now holds starting offset }
  les  di,renderBuffer
  mov  dx,ds
	lds  si,sourceBuffer
	add  di,bx
	add  si,bx

	mov  bx,$004C
	mov  cx,9

{	mov  ax,$F7F7 }
@loop:
{	stosw
	stosw
}
	movsw
	movsw

	add  si,bx
	add  di,bx
	loop @loop

	mov  ds,dx
end;

{
	show copies an 8x6 section from renderBuffer to display
	ON THE BYTE BOUNDARY!!!
}
procedure buffer_show4x3(x,y:integer); assembler;
asm
	mov  ax,y
	mov  bx,$A0
	mul  bx
	mov  bx,x
	add  bx,ax
	mov  di,bx
	or   di,1

	shr  bx,1

	mov  ax,$B800
	mov  es,ax

	mov  dx,ds
	lds  si,renderBuffer
	add  si,bx
	mov  cx,3
	mov  ah,$DD
	mov  bx,$009C

@loop:
	lodsb
	stosw
	lodsb
	stosw
	add  si,$004E
	add  di,bx
	loop @loop

	mov  ds,dx
end;

{
	show copies an 8x6 section from renderBuffer to display
	ON THE BYTE BOUNDARY!!!
}
procedure buffer_show8x6(x,y:integer); assembler;
asm
	mov  ax,y
	mov  bx,$A0
	mul  bx
	mov  bx,x
	add  bx,ax
	mov  di,bx
	or   di,1

	shr  bx,1

	mov  ax,$B800
	mov  es,ax

	mov  dx,ds
	lds  si,renderBuffer
	add  si,bx
	mov  cx,8
	mov  bx,$0098

@loop:
	movsb
	inc  di
	movsb
	inc  di
	movsb
	inc  di
	movsb
	inc  di
	add  si,$004C
	add  di,bx
	loop @loop

	mov  ds,dx
end;

{
	draws a 3x3 tile to the source buffer
}
procedure buffer_sourceTile3(x,y:integer; tileSet:pointer; tile:byte); assembler;
asm
	{ set video address for STOSW }
	mov  ax,y
	mov  bx,$50
	mul  bx
	mov  bx,x
	mov  cx,bx
	shr  bx,1
	add  bx,ax { bx now holds offset }
	les  di,sourceBuffer
	add  di,bx

	{ calculate tile offset }
	xor  ax,ax
	mov  al,tile
	mov  bx,24
	mul  bx
	and  cx,1
	jnz  @oddtile
	add  ax,12
@oddTile:
	mov  dx,ds
	lds  si,tileSet
	add  si,ax

	mov  cx,3

@loop:

	lodsw
	mov  bx,ax
	mov  al,es:[di]
	and  al,bh
	or   al,bl
	stosb

	lodsw
	mov  bx,ax
	mov  al,es:[di]
	and  al,bh
	or   al,bl
	stosb

	add  di,$4E

	loop @loop

	mov ds,dx
end;

{
	draws a 5x5 tile to the source buffer
}
procedure buffer_sourceTile5(x,y:integer; tileSet:pointer; tile:byte); assembler;
asm
	{ set video address for STOSW }
	mov  ax,y
	mov  bx,$50
	mul  bx
	mov  cx,x
	mov  bx,cx
	shr  bx,1
	add  bx,ax { bx now holds offset }
	les  di,sourceBuffer
	add  di,bx

	{ calculate tile offset }
	xor  ax,ax
	mov  al,tile
	mov  bx,60
	mul  bx
	and  cx,1
	jnz  @oddtile
	add  ax,30
@oddTile:
	mov  dx,ds
	lds  si,tileSet
	add  si,ax

	mov  cx,5

@loop:

	lodsw
	mov  bx,ax
	mov  al,es:[di]
	and  al,bh
	or   al,bl
	stosb

	lodsw
	mov  bx,ax
	mov  al,es:[di]
	and  al,bh
	or   al,bl
	stosb

	lodsw
	mov  bx,ax
	mov  al,es:[di]
	and  al,bh
	or   al,bl
	stosb

	add  di,$4D

	loop @loop

	mov ds,dx
end;

{
	draws a 3x3 tile to the render buffer
}
procedure buffer_renderTile3(x,y:integer; tileSet:pointer; tile:byte); assembler;
asm
	{ set video address for STOSW }
	mov  ax,y
	mov  bx,$50
	mul  bx
	mov  bx,x
	mov  cx,bx
	shr  bx,1
	add  bx,ax { bx now holds offset }
	les  di,renderBuffer
	add  di,bx

	{ calculate tile offset }
	xor  ax,ax
	mov  al,tile
	mov  bx,24
	mul  bx
	and  cx,1
	jnz  @oddtile
	add  ax,12
@oddTile:
	mov  dx,ds
	lds  si,tileSet
	add  si,ax

	mov  cx,3

@loop:

	lodsw
	mov  bx,ax
	mov  al,es:[di]
	and  al,bh
	or   al,bl
	stosb

	lodsw
	mov  bx,ax
	mov  al,es:[di]
	and  al,bh
	or   al,bl
	stosb

	add  di,$4E

	loop @loop

	mov ds,dx
end;

{
	draws a 5x5 tile to the render buffer
}
procedure buffer_renderTile5(x,y:integer; tileSet:pointer; tile:byte); assembler;
asm
	{ set video address for STOSW }
	mov  ax,y
	mov  bx,$50
	mul  bx
	mov  cx,x
	mov  bx,cx
	shr  bx,1
	add  bx,ax { bx now holds offset }
	les  di,renderBuffer
	add  di,bx

	{ calculate tile offset }
	xor  ax,ax
	mov  al,tile
	mov  bx,60
	mul  bx
	and  cx,1
	jnz  @oddtile
	add  ax,30
@oddTile:
	mov  dx,ds
	lds  si,tileSet
	add  si,ax

	mov  cx,5

@loop:

	lodsw
	mov  bx,ax
	mov  al,es:[di]
	and  al,bh
	or   al,bl
	stosb

	lodsw
	mov  bx,ax
	mov  al,es:[di]
	and  al,bh
	or   al,bl
	stosb

	lodsw
	mov  bx,ax
	mov  al,es:[di]
	and  al,bh
	or   al,bl
	stosb

	add  di,$4D

	loop @loop

	mov ds,dx
end;

{
	erases a 4x3 area on the byte boundary from sourceBuffer
	byte-bound
}
procedure buffer_nullTile4x3(x,y:integer); assembler;
asm
	{ set video address for STOSW }
	les  di,sourceBuffer
	mov  ax,y
	mov  bx,$50
	mul  bx
	add  di,ax
	mov  cx,x
	shr  cx,1
	add  di,cx
	xor  ax,ax
	mov  cx,3
	mov  bx,$50
@loop:
	mov  es:[di],ax
	add  di,bx
	loop @loop
end;

procedure buffer_showSprites;
var
	tSprite:pSprite;
begin
	tSprite:=firstSprite;
	while not(tSprite=nil) do with tSprite^ do begin
		bufferShow(currentX,currentY);
		oldX:=currentX;
		oldY:=currentY;
		tSprite:=next;
	end;
end;

procedure buffer_hideSprites;
var
	tSprite:pSprite;
begin
	tSprite:=firstSprite;
	while not(tSprite=nil) do with tSprite^ do begin
		buffer_restore(oldX,oldY);
		tSprite:=next;
	end;
	tSprite:=firstSprite;
	while not(tSprite=nil) do with tSprite^ do begin
		bufferShow(oldX,oldY);
		tSprite:=next;
	end;
end;

procedure buffer_updateSprites;
var
	tSprite:pSprite;
	pUpdate:pUpdateBlock;
begin

	tSprite:=firstSprite;
	while not(tSprite=nil) do with tSprite^ do begin
		bufferWriteTile(currentX,currentY,sTiles^.dataStart,currentTile);
		tSprite:=next;
	end;

	tSprite:=firstSprite;
	while not(tSprite=nil) do with tSprite^ do begin
		if currentX<oldX then bufferX:=currentX else bufferX:=oldX;
		oldX:=currentX;
		if currentY<oldY then bufferY:=currentY else bufferY:=oldY;
		oldY:=currentY;
		bufferShow(bufferX,bufferY);
		tSprite:=next;
	end;

	pUpdate:=updateList.first;
	while not(pUpdate=nil) do with pUpdate^ do begin
		buffer_Show4x3(x,y);
		pUpdate:=next;
	end;

	tSprite:=firstSprite;
	while not(tSprite=nil) do with tSprite^ do begin
		buffer_restore(currentX,currentY);
		tSprite:=next;
	end;

	pUpdate:=updateList.first;
	while not(pUpdate=nil) do with pUpdate^ do begin
		buffer_restore(x,y);
		pUpdate:=next;
	end;
end;

procedure tg_clear(color:byte); assembler;
asm { clear video memory }
	mov  ax,textSegment
	mov  es,ax
	xor  di,di
	mov  ah,color
	mov  bl,ah
	mov  cl,4
	shl  bl,cl
	and  ah,$0F
	or   ah,bl
	mov  al,$DD
	mov  cx,pageSize
	shr  cx,1
	rep  stosw
	xor  al,al
	mov  tg_erase,al
end;

procedure tg_init;
var
	t:word;
begin
	oldMode:=getVideoMode;
	setVideoMode($02);
	buffer_sourceClear(0);
	buffer_copySource2Render;
	buffer_copyRender2Screen;

	disableVideoOutputAndInterrupts;

	case videoCard of

		videoCard_cga:outCGAPort(@CGA_Regs);

		videoCard_tandy1000,
		videoCard_tandySLTL,
		videoCard_pcJr:begin
			outCGAPort(@CGA_Regs);
			brownFix;
		end;

		videoCard_ega:begin
			if paramExists('/safe') then begin
				egaVgaSafe(2); { set fonts to 3px tall }
			end else begin
				egaVgaUnsafe;
				outEGAVGAPort(@EGA_Sequencer);
				outEGAVGAPort(@EGA_CRTC);
				brownFix;
			end;
		end;

		videoCard_vga:begin
			if paramExists('/safe') then begin
				egaVgaSafe(3); { set fonts to 4px tall }
			end else begin
				egaVgaUnsafe;
				outEGAVGAPort(@VGA_Sequencer);
				outEGAVGAPort(@VGA_CRTC);
			end;
		end;
	end;

	enableVideoOutputAndInterrupts;

	textGraphOn:=true;

	with clippingWindow do begin
		sx:=0;   sy:=0;
		ex:=159; ey:=99;
	end;

end;

procedure tg_term;
begin
	setVideoMode(oldMode);
	textGraphOn:=false;
end;

{
	adding our own custom exitproc is a safeguard so that
	if someone using this library forgets to call tg_term
	the program will still exit to text mode. I WISH that
	execution breaks or failures would call exitproc.

	A more robust unit would add a custom error handler.
}
procedure tg_exitProc; far;
begin
	if textGraphOn then tg_term;
	discardSprites;
	dispose(renderBuffer);
	dispose(sourceBuffer);
	updateList.term;
	exitProc:=oldTgExitProc;
end;

begin
	write('Video card detected: ');
	videoCard:=detectCard;
	writeln(videoCardName[videoCard]);
	if (videoCard=videoCard_MDA) then begin
		writeln('This program does not work on a monochrome display adapter!');
		halt;
	end;
	firstSprite:=nil;
	lastSprite:=nil;
	textSegment:=$B800;
	textGraphOn:=false;
	updateList.init;
	new(sourceBuffer);
	new(renderBuffer);
	oldTgExitProc:=exitProc;
	exitProc:=@tg_exitProc;
end.